home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr16.lha / env.lisp < prev    next >
Lisp/Scheme  |  1993-01-07  |  11KB  |  332 lines
  1. ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; Basic environmental stuff.
  28. ;;;
  29.  
  30. (in-package :pcl)
  31.  
  32. #+Lucid
  33. (progn
  34.  
  35. (defun pcl-arglist (function &rest other-args)
  36.   (let ((defn nil))
  37.     (cond ((and (fsc-instance-p function)
  38.         (generic-function-p function))
  39.        (generic-function-pretty-arglist function))
  40.       ((and (symbolp function)
  41.         (fboundp function)
  42.         (setq defn (symbol-function function))
  43.         (fsc-instance-p defn)
  44.         (generic-function-p defn))
  45.        (generic-function-pretty-arglist defn))
  46.       (t (apply (original-definition 'sys::arglist)
  47.             function other-args)))))
  48.  
  49. (redefine-function 'sys::arglist 'pcl-arglist)
  50.  
  51. )
  52.  
  53.  
  54. ;;;
  55. ;;;
  56. ;;;
  57.  
  58. (defgeneric describe-object (object stream))
  59.  
  60. #-Genera
  61. (progn
  62.  
  63. (defun pcl-describe (object #+Lispm &optional #+Lispm no-complaints)
  64.   (let (#+Lispm (*describe-no-complaints* no-complaints))
  65.     #+Lispm (declare (special *describe-no-complaints*))
  66.     (describe-object object *standard-output*)
  67.     (values)))
  68.  
  69. (defmethod describe-object (object stream)
  70.   (let ((*standard-output* stream))
  71.     (cond ((or #+kcl (packagep object))
  72.        (describe-package object stream))
  73.       (t
  74.        (funcall (original-definition 'describe) object)))))
  75.  
  76. (redefine-function 'describe 'pcl-describe)
  77.  
  78. )
  79.  
  80. (defmethod describe-object ((object slot-object) stream)
  81.   (let* ((class (class-of object))
  82.      (slotds (slots-to-inspect class object))
  83.      (max-slot-name-length 0)
  84.      (instance-slotds ())
  85.      (class-slotds ())
  86.      (other-slotds ()))
  87.     (flet ((adjust-slot-name-length (name)
  88.          (setq max-slot-name-length
  89.            (max max-slot-name-length
  90.             (length (the string (symbol-name name))))))
  91.        (describe-slot (name value &optional (allocation () alloc-p))
  92.          (if alloc-p
  93.          (format stream
  94.              "~% ~A ~S ~VT  ~S"
  95.              name allocation (+ max-slot-name-length 7) value)
  96.          (format stream
  97.              "~% ~A~VT  ~S"
  98.              name max-slot-name-length value))))
  99.       ;; Figure out a good width for the slot-name column.
  100.       (dolist (slotd slotds)
  101.     (adjust-slot-name-length (slot-definition-name slotd))
  102.     (case (slot-definition-allocation slotd)
  103.       (:instance (push slotd instance-slotds))
  104.       (:class  (push slotd class-slotds))
  105.       (otherwise (push slotd other-slotds))))
  106.       (setq max-slot-name-length  (min (+ max-slot-name-length 3) 30))
  107.       (format stream "~%~S is an instance of class ~S:" object class)
  108.  
  109.       (when instance-slotds
  110.     (format stream "~% The following slots have :INSTANCE allocation:")
  111.     (dolist (slotd (nreverse instance-slotds))
  112.       (describe-slot (slot-definition-name slotd)
  113.              (slot-value-or-default object (slot-definition-name slotd)))))
  114.  
  115.       (when class-slotds
  116.     (format stream "~% The following slots have :CLASS allocation:")
  117.     (dolist (slotd (nreverse class-slotds))
  118.       (describe-slot (slot-definition-name slotd)
  119.              (slot-value-or-default object (slot-definition-name slotd)))))
  120.  
  121.       (when other-slotds 
  122.     (format stream "~% The following slots have allocation as shown:")
  123.     (dolist (slotd (nreverse other-slotds))
  124.       (describe-slot (slot-definition-name slotd)
  125.              (slot-value-or-default object (slot-definition-name slotd))
  126.              (slot-definition-allocation slotd))))
  127.       (values))))
  128.  
  129. (defmethod slots-to-inspect ((class slot-class) (object slot-object))
  130.   (class-slots class))
  131.  
  132. (defvar *describe-metaobjects-as-objects-p* nil)
  133.  
  134. (defmethod describe-object ((fun standard-generic-function) stream)
  135.   (format stream "~A is a generic function.~%" fun)
  136.   (format stream "Its arguments are:~%  ~S~%"
  137.           (generic-function-pretty-arglist fun))
  138.   (format stream "Its methods are:")
  139.   (dolist (meth (generic-function-methods fun))
  140.     (format stream "~2%    ~{~S ~}~:S =>~%"
  141.             (method-qualifiers meth)
  142.             (unparse-specializers meth))
  143.     (describe-object (or (method-fast-function meth)
  144.              (method-function meth))
  145.              stream))
  146.   (when *describe-metaobjects-as-objects-p*
  147.     (call-next-method)))
  148.  
  149. ;;;
  150. ;;;
  151. ;;;
  152. (defmethod describe-object ((class class) stream)
  153.   (flet ((pretty-class (c) (or (class-name c) c)))
  154.     (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
  155.       (ft "~&~S is a class, it is an instance of ~S.~%"
  156.       class (pretty-class (class-of class)))
  157.       (let ((name (class-name class)))
  158.     (if name
  159.         (if (eq class (find-class name nil))
  160.         (ft "Its proper name is ~S.~%" name)
  161.         (ft "Its name is ~S, but this is not a proper name.~%" name))
  162.         (ft "It has no name (the name is NIL).~%")))
  163.       (ft "The direct superclasses are: ~:S, and the direct~%~
  164.            subclasses are: ~:S.  The class precedence list is:~%~S~%~
  165.            There are ~D methods specialized for this class."
  166.       (mapcar #'pretty-class (class-direct-superclasses class))
  167.       (mapcar #'pretty-class (class-direct-subclasses class))
  168.       (mapcar #'pretty-class (class-precedence-list class))
  169.       (length (specializer-direct-methods class)))))
  170.   (when *describe-metaobjects-as-objects-p*
  171.     (call-next-method)))
  172.  
  173. (defun describe-package (object stream)
  174.   (unless (packagep object) (setq object (find-package object)))
  175.   (format stream "~&~S is a ~S.~%" object (type-of object))
  176.   (let ((nick (package-nicknames object)))
  177.     (when nick
  178.       (format stream "You can also call it~@[ ~{~S~^, ~} or~] ~S.~%"
  179.           (butlast nick) (first (last nick)))))  
  180.   (let* (#+cmu (internal (lisp::package-internal-symbols object))
  181.      (internal-count #+cmu (- (lisp::package-hashtable-size internal)
  182.                   (lisp::package-hashtable-free internal))
  183.              #-cmu 0)
  184.      #+cmu (external (lisp::package-external-symbols object))
  185.      (external-count #+cmu (- (lisp::package-hashtable-size external)
  186.                   (lisp::package-hashtable-free external))
  187.              #-cmu 0))
  188.     #-cmu (do-external-symbols (sym object)
  189.         (declare (ignore sym))
  190.         (incf external-count))
  191.     #-cmu (do-symbols (sym object)
  192.         (declare (ignore sym))
  193.         (incf internal-count))
  194.     #-cmu (decf internal-count external-count)
  195.     (format stream "It has ~D internal and ~D external symbols (~D total).~%"
  196.         internal-count external-count (+ internal-count external-count)))
  197.   (let ((used (package-use-list object)))
  198.     (when used
  199.       (format stream "It uses the packages ~{~S~^, ~}.~%"
  200.           (mapcar #'package-name used))))
  201.   (let ((users (package-use-list object)))
  202.     (when users
  203.       (format stream "It is used by the packages ~{~S~^, ~}.~%"
  204.           (mapcar #'package-name users)))))
  205.  
  206. #+cmu
  207. (defmethod describe-object ((object package) stream)
  208.   (describe-package object stream))
  209.  
  210. #+cmu
  211. (defmethod describe-object ((object hash-table) stream)
  212.   (format stream "~&~S is an ~a hash table."
  213.       object
  214.       #-cmu17 (lisp::hash-table-kind object)
  215.       #+cmu17 (lisp::hash-table-test object))
  216.   (format stream "~&Its size is ~d buckets."
  217.       (lisp::hash-table-size object))
  218.   (format stream "~&Its rehash-size is ~d."
  219.       (lisp::hash-table-rehash-size object))
  220.   (format stream "~&Its rehash-threshold is ~d."
  221.       (lisp::hash-table-rehash-threshold object))
  222.   (format stream "~&It currently holds ~d entries."
  223.       (lisp::hash-table-number-entries object)))
  224.  
  225.  
  226.  
  227. ;;;
  228. ;;; trace-method and untrace-method accept method specs as arguments.  A
  229. ;;; method-spec should be a list like:
  230. ;;;   (<generic-function-spec> qualifiers* (specializers*))
  231. ;;; where <generic-function-spec> should be either a symbol or a list
  232. ;;; of (SETF <symbol>).
  233. ;;;
  234. ;;;   For example, to trace the method defined by:
  235. ;;;
  236. ;;;     (defmethod foo ((x spaceship)) 'ss)
  237. ;;;
  238. ;;;   You should say:
  239. ;;;
  240. ;;;     (trace-method '(foo (spaceship)))
  241. ;;;
  242. ;;;   You can also provide a method object in the place of the method
  243. ;;;   spec, in which case that method object will be traced.
  244. ;;;
  245. ;;; For untrace-method, if an argument is given, that method is untraced.
  246. ;;; If no argument is given, all traced methods are untraced.
  247. ;;;
  248. (defclass traced-method (method)
  249.      ((method :initarg :method)
  250.       (function :initarg :function
  251.         :reader method-function)
  252.       (generic-function :initform nil
  253.             :accessor method-generic-function)))
  254.  
  255. (defmethod method-lambda-list ((m traced-method))
  256.   (with-slots (method) m (method-lambda-list method)))
  257.  
  258. (defmethod method-specializers ((m traced-method))
  259.   (with-slots (method) m (method-specializers method)))
  260.  
  261. (defmethod method-qualifiers ((m traced-method))
  262.   (with-slots (method) m (method-qualifiers method)))
  263.  
  264. (defmethod accessor-method-slot-name ((m traced-method))
  265.   (with-slots (method) m (accessor-method-slot-name method)))
  266.  
  267. (defvar *traced-methods* ())
  268.  
  269. (defun trace-method (spec &rest options)
  270.   #+copy-&rest-arg (setq options (copy-list options))
  271.   (multiple-value-bind (gf omethod name)
  272.       (parse-method-or-spec spec)
  273.     (let* ((tfunction (trace-method-internal (method-function omethod)
  274.                          name
  275.                          options))
  276.        (tmethod (make-instance 'traced-method
  277.                    :method omethod
  278.                    :function tfunction)))
  279.       (remove-method gf omethod)
  280.       (add-method gf tmethod)
  281.       (pushnew tmethod *traced-methods*)
  282.       tmethod)))
  283.  
  284. (defun untrace-method (&optional spec)  
  285.   (flet ((untrace-1 (m)
  286.        (let ((gf (method-generic-function m)))
  287.          (when gf
  288.            (remove-method gf m)
  289.            (add-method gf (slot-value m 'method))
  290.            (setq *traced-methods* (remove m *traced-methods*))))))
  291.     (if (not (null spec))
  292.     (multiple-value-bind (gf method)        
  293.         (parse-method-or-spec spec)
  294.       (declare (ignore gf))
  295.       (if (memq method *traced-methods*)
  296.           (untrace-1 method)
  297.           (error "~S is not a traced method?" method)))
  298.     (dolist (m *traced-methods*) (untrace-1 m)))))
  299.  
  300. (defun trace-method-internal (ofunction name options)
  301.   (eval `(untrace ,name))
  302.   (setf (symbol-function name) ofunction)
  303.   (eval `(trace ,name ,@options))
  304.   (symbol-function name))
  305.  
  306.  
  307.  
  308.  
  309. ;(defun compile-method (spec)
  310. ;  (multiple-value-bind (gf method name)
  311. ;      (parse-method-or-spec spec)
  312. ;    (declare (ignore gf))
  313. ;    (compile name (method-function method))
  314. ;    (setf (method-function method) (symbol-function name))))
  315.  
  316. (defmacro undefmethod (&rest args)
  317.   #+(or (not :lucid) :lcl3.0)
  318.   (declare (arglist name {method-qualifier}* specializers))
  319.   `(undefmethod-1 ',args))
  320.  
  321. (defun undefmethod-1 (args)
  322.   (multiple-value-bind (gf method)
  323.       (parse-method-or-spec args)
  324.     (when (and gf method)
  325.       (remove-method gf method)
  326.       method)))
  327.  
  328.  
  329. (pushnew :pcl *features*)
  330. (pushnew :portable-commonloops *features*)
  331. (pushnew :pcl-structures *features*)
  332.